home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
boi120p.zip
/
UNITS.ZIP
/
IOLIB.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1990-12-12
|
16KB
|
548 lines
{$D-}
{$S-}
{$V-}
Unit IOLib;
{ Part of BBS Onliner Interface }
{ Copyright (C) 1990 Andrew J. Mead
All Rights Reserved. }
{ BBS Onliner Interface contains
Async - low-level serial port communications interrupt handler
BOIDecl - BOI standard declarations
IOLib - standard console and port communications routines
IOSupp - extended character code processing for IOLib-ReadPortKey
GetCmBBS - command line parser
Support - common library functions and procedures }
{ Original version 7/1/90
Original release version 1.0 beta 9/5/90
Version 1.01 9/19/90 /Q quiet local mode switch added
Version 1.01b 9/20/90 realname usage added, /A Remote Access defined
Version 1.02 9/22/90 RA access removed, /Q switch fixed
Version 1.03 9/23/90 /A play it Again switch added
Version 1.10 9/24/90 /2, /F, /M, /H, /5, /6 switches added
Version 1.11 9/29/90 beta version of /B locked baud rate
Version 1.12 10/ 1/90 /P switch added
Version 1.13 10/10/90 /N switch added
Version 1.14 10/22/90 /B switch fixed, carrier dectect routines added
Version 1.15 10/25/90 internal reorginizations, /K added
Version 1.16 11/ 9/90 /K fixed, F-9 abort added.
Version 1.17 12/ 1/90 internal reorginizations.
Version 1.17b12/ 5/90 /P fixed, /O implemented
Version 1.18 12/ 9/90 /O,/P verified /1,/3 implemented.
Version 1.20 12/10/90 Initial Public Release.
}
INTERFACE
Uses
Dos;
{ Standard Functions }
Function MIN(a,b : word) : word;
Function MAX(a,b : word) : word;
{* Internal timing *}
Procedure TIMERSET(var basetime : longint); { initialize timer value }
Function GETTIMER( {boolean} { true if val seconds has passed }
var basetime : longint; { starting time }
val : word) { number of seconds }
: boolean;
{* file validation *}
Function EXIST(thisfile : pathstr) : boolean;
Function VALID(thisfile : pathstr) : boolean;
{ Memory Function }
Function KEYPRESSED : Boolean; { RAM - check keyboard buffer }
{ BIOS Functions }
Function READKEY : char; { BIOS - get key from keyboard buffer }
Function WHEREX : byte; { BIOS - get current cursor x position }
Function WHEREY : byte; { BIOS - get current cursor y position }
Procedure DELAY(ms : Word); { BIOS - CPU delay, 993 = 1 second }
{ ANSI Functions }
{ Input/Output string procedures }
Procedure SENDSTRING( { send string to output }
outstr : string; { string to output }
docr : boolean); { send CR/LF indicator }
Function INTSTR( { returns a string of the input integer }
val : longint; { value to convert }
isize : byte) : string; { padded size of the string }
Function REALSTR({ returns a string of the input real value }
rval : real; { value to convert }
rsize, { padded size of the string }
rdec : byte) : string; { number of decimal places in string }
Function PADSTR( { returns a right justified string }
pstr : string; { string to right justify }
psize : byte) : string; { size of string }
Procedure GETSTRING(var gstr : string); { all input chars upto next CR }
{ Housecleaning procedures }
Procedure SETPORT; { Initialize Async Communications }
Procedure ENDPORT; { Terminate Async Communications }
{ Positional/Attribute Functions }
Procedure GOTOPORTXY(x,y : byte); { Position cursor at given coordinates }
Procedure PORTCOLOR( { if docolor then set acolor else set bcolor }
acolor, { color text attributes }
bcolor : byte); { monochrome text attributes }
Procedure TEXTPORTCOLOR(color : byte); { set text attributes }
Procedure PORTBACKGROUND(color: byte); { set background attributes }
Procedure CLRPORTSCR; { clear current window }
Procedure CLRPORTEOL; { clear current line to End Of Line }
Procedure PORTWINDOW(x1,y1,x2,y2 : byte); { Set display Window }
Procedure PORTCOLUMNONE; { put cursor in column one on current line }
{ Basic Input function }
Function READPORTKEY : char; { get input character }
Function PORTKEYPRESSED : boolean; { character ready for processing }
{ reset function }
Procedure CLEARBUFFERS; { clear keyboard and port input buffers }
{ Advanced positional group }
Procedure SETPORTXY; { save current cursor position }
Procedure RESETPORTXY; { restore saved cursor position }
{ Timeout procedure }
Function LEFTTIME : integer; { remaing player time in minutes }
Procedure DOTIMEOUT(ringbell : boolean); { exit program due to inactivity }
IMPLEMENTATION
Uses
boidecl,
iosupp,
Async;
Const
null = #0;
bell = #7;
esc = #27;
f10 = #$44; {scan code}
basex : byte = 1;
basey : byte = 1;
tempx : byte = 1;
tempy : byte = 1;
endx : byte = 24;
endy : byte = 80;
Var
regs : registers;
textattr : word;
workstr : string;
Function MIN(a,b : word) : word;
begin {* fMin *}
if a < b then Min := a else Min := b
end; {* fMin *}
Function MAX(a,b : word) : word;
begin {* fMax *}
if a > b then Max := a else Max := b
end; {* fMax *}
Procedure TIMERSET(var basetime : longint);
begin {* TimerSet *}
move(memw[$40:$6C],basetime,4)
end; {* TimerSet *}
Function GETTIMER(var basetime : longint; val : word) : boolean;
var thistime : longint;
begin {* GetTimer *}
move(memw[$40:$6C],thistime,4);
GetTimer := trunc((thistime - basetime) / 18.2) > val;
end; {* GetTimer *}
Function EXIST(thisfile : pathstr) : boolean;
var
afile : file;
iocode : word;
begin {* fExist *}
assign(afile,thisfile);
{$I-}
reset(afile);
{$I+}
iocode := ioresult;
Exist := (iocode = 0);
if iocode = 0 then close(afile);
end; {* fExist *}
Function VALID(thisfile : pathstr) : boolean;
Var
afile : file;
check : boolean;
iocode : word;
begin {* fValid *}
if not Exist(thisfile) then
begin
assign(afile,thisfile);
{$I-}
rewrite(afile);
close(afile);
erase(afile);
{$I+}
iocode := ioresult;
Valid := (iocode = 0)
end
else Valid := true
end; {* fValid *}
Procedure DELAY(MS: Word);
begin {* Delay *}
with regs do
begin
ah := $86;
move(ms,cx,2);
Intr($15,regs)
end
end; {* Delay *}
Function KEYPRESSED : Boolean;
begin {* KeyPressed *}
Keypressed := MemW[$0040:$001C] <> MemW[$0040:$001A]
end; {* KeyPressed *}
Function READKEY : char;
var key : char;
begin {* fReadKey *}
setfunction := false;
with regs do
begin
repeat { wait until keypressed }
begin
ah := $01; { check to see if keyboard buffer is empty }
Intr($16,regs)
end
until flags and fzero = 0;
ah := $00; { get next keycode from keyboard buffer }
Intr($16,regs);
move(al,key,1);
if key = null then { if local keyboard has pressed a function }
begin { key, replace the #0 value with the scan }
setfunction := true; { code of the key pressed. }
move(ah,key,1)
end;
ReadKey := key
end
end; {* fReadKey *}
Function WHEREX : byte;
begin {* fWhereX *}
with regs do
begin
ah := $03;
bh := $00;
Intr($10,regs);
WhereX := dl + 2 - baseX
end
end; {* fWhereX *}
Function WHEREY : byte;
begin {* fWhereY *}
with regs do
begin
ah := $03;
bh := $00;
Intr($10,regs);
WhereY := dh + 2 - baseY
end
end; {* fWhereY *}
Procedure SENDSTRING(outstr : string;docr : boolean);
var
sloop : byte;
begin {* SendString *}
if not dolocal then
begin
for sloop := 1 to length(outstr) do SendChar(outstr[sloop]);
if docr then
begin
SendChar(char($0D)); { send CR }
SendChar(char($0A)) { send LF }
end
end;
if dolocal or doecho then
begin
if doquiet then for sloop := length(outstr) downto 1 do if outstr[sloop] = bell then delete(outstr,sloop,1);
write(outstr);
if docr then writeln
end
end; {* SendString *}
Function INTSTR(val : longint;isize : byte) : string;
var
ist : string;
begin {* fIntStr *}
Str(val:isize,ist);
IntStr := ist
end; {* fIntStr *}
Function REALSTR(rval : real; rsize,rdec : byte) : string;
var
ist : string;
begin {* fRealStr *}
Str(rval:rsize:rdec,ist);
RealStr := ist
end; {* fRealStr *}
Function PADSTR(pstr : string; psize : byte) : string;
var
tstr : string;
begin {* fPadStr *}
if length(pstr) > psize then PadStr := pstr
else
begin
fillchar(tstr[1],psize,32);
tstr[0] := chr(psize);
move(pstr[1],tstr[psize - length(pstr) + 1],length(pstr));
PadStr := tstr
end
end; {* fPadStr *}
Function READPORTKEY : char;
var
rkey : char;
timebase : longint;
begin {* fReadPortKey *}
if dolocal then
begin
rkey := ReadKey;
if setfunction then CheckSecondKey(rkey)
end
else
begin
TimerSet(timebase);
repeat until CharReady or KeyPressed or GetTimer(timebase,60) or not Carrier;
if not (KeyPressed or CharReady) and Carrier and GetTimer(timebase,60) then
begin
SendString(bell,false);
repeat until charready or keypressed or GetTimer(timebase,120) or not Carrier
end;
if not Carrier then DoTimeOut(false)
else if not (KeyPressed or CharReady) and GetTimer(timebase,120) then DoTimeOut(true)
else if CharReady then rkey := ReadBuffer
else if KeyPressed then
begin
rkey := ReadKey;
if setfunction then CheckSecondKey(rkey)
end
end;
ReadPortKey := rkey
end; {* fReadPortKey *}
Function PORTKEYPRESSED : boolean;
begin {* fPortKeyPressed *}
if dolocal then PortKeyPressed := KeyPressed
else PortKeyPressed := KeyPressed or CharReady
end; {* fPortKeyPressed *}
Procedure CLEARBUFFERS;
var cbchar : char;
begin {* ClearBuffers *}
while keypressed do cbchar := ReadKey;
if not dolocal then ClearInBuffer
end; {* ClearBuffers *}
Procedure GETSTRING(var gstr : string);
var
gchar : char;
begin {* GetString *}
if dolocal then readln(gstr)
else
begin
gstr := '';
repeat
begin
gchar := ReadPortKey;
if gchar in [#32..#126] then
begin
gstr := gstr + gchar;
SendString(gchar,false)
end
else if (gchar = #8) and (length(gstr) > 0) then
begin
delete(gstr,length(gstr),1);
SendString(gchar,false)
end
end
until gchar = #13;
SendString('',true)
end
end; {* GetString *}
Procedure SETPORT;
begin {* SetPort *}
if not dolocal then IntInit
end; {* SetPort *}
Procedure ENDPORT;
begin {* EndPort *}
if not dolocal then IntEnd
end; {* EndPort *}
Procedure GOTOPORTXY(x,y : byte);
begin {* GotoPortXY *}
x := x + basex - 1;
y := y + basey - 1;
SendString(esc+'['+IntStr(y,0)+';'+IntStr(x,0)+'H',false)
end; {* GotoPortXY *}
Procedure SETCOLOR(color : byte);
begin {* SetColor *}
if color > 150 then {* Blink + High Intensity *}
begin
SendString(esc+'[01;05;'+IntStr(color-150,0)+'m',false);
textattr := 0
end
else if color > 100 then {* Blink + Low Intensity *}
begin
SendString(esc+'[00;05;'+IntStr(color-100,0)+'m',false);
textattr := 0
end
else if color > 50 then {* High Intesity *}
begin
SendString(esc+'[00;01;'+IntStr(color-50,0)+'m',false);
textattr := 0
end
else {* Low Intesity *}
begin
SendString(esc+'[00;'+IntStr(color,0)+'m',false);
textattr := 0
end
end; {* SetColor *}
Procedure PORTCOLOR(acolor, bcolor : byte);
begin {* PortColor *}
if docolor then SetColor(acolor) else SetColor(bcolor)
end; {* PortColor *}
Procedure TEXTPORTCOLOR(color : byte);
begin {* TextPortColor *}
SetColor(color)
end; {* TextPortColor *}
Procedure PORTBACKGROUND(color: byte);
begin {* PortBackground *}
if color in [30..37] then SendString(esc+'[00;'+IntStr(color+10,0)+'m',false)
end; {* PortBackground *}
Procedure CLRPORTSCR;
var
cloop : byte;
Procedure GOTOSTATUSLINE;
begin {* ClrPortScr,GotoStatusLine *}
with regs do
begin
ah := $02; { use BIOS gotoxy function }
bh := $00; { use current video screen }
dh := 24; { goto line 24 (0-24) }
dl := 0; { goto column 0 (0-79) }
Intr($10,regs)
end
end; {* ClrPortScr,GotoStatusLine *}
begin {* ClrPortScr *}
if basey = 1 then
begin
SendString(esc+'[2J',false);
if usename and not dolocal then
begin
SetPortXY;
GotoStatusLine;
workstr := 'Current Player : ' + username;
if usereal then workstr := workstr + ', ' + realname;
if length(workstr) > 79 then workstr[0] := chr(79);
write(workstr);
ResetPortXY
end
end
else for cloop := endy - basey + 1 downto 1 do
begin
GotoPortXY(1,cloop);
if cloop < 24 then SendString(esc+'[K',false)
else SendString(' ',false)
end
end; {* ClrPortScr *}
Procedure CLRPORTEOL;
begin {* ClrPortEOL *}
SendString(esc+'[K',false)
end; {* ClrPortEOL *}
Procedure PORTWINDOW(x1,y1,x2,y2 : byte);
begin {* PortWindow *}
basex := x1;
basey := y1;
endx := Min(80,x2);
endy := Min(24,y2);
GotoPortXY(1,1);
end; {* PortWindow *}
Procedure PORTCOLUMNONE;
begin {* PortColumnOne *}
SendString(esc+'[79D',false)
end; {* PortColumnOne *}
Procedure SETPORTXY;
begin {* SetPortXY *}
SendString(esc+'[s',false);
if doecho then
begin
TempX := WhereX;
TempY := WhereY
end
end; {* SetPortXY *}
Procedure RESETPORTXY;
Procedure GOTOXY(x,y : byte);
begin {* GotoXY *}
x := x + basex - 1;
y := y + basey - 1;
write(esc,'[',y:0,';',x:0,'H')
end; {* GotoXY *}
begin {* ResetPortXY *}
SendString(esc+'[u',false);
if doecho then gotoxy(TempX,TempY)
end; {* ResetPortXY *}
Procedure DOTIMEOUT(ringbell : boolean);
begin {* DoTimeOut *}
if ringbell then SendString(bell,true);
write(esc,'[2J');
write('Program timeout. ');
if Carrier then writeln('No input for 2 minutes.') else writeln('Carrier Dropped.');
writeln('Returning control to BBS.');
EndPort;
halt
end; {* DoTimeOut *}
Function LEFTTIME : integer;
begin {* fLeftTime *}
GetTime(thishour,thismin,second,hunsec);
if (hour = 23) and (thishour = 0) then thishour := 24;
LeftTime := timeleft + minute-thismin - 60*(thishour-hour)
end; {* fLeftTime *}
end. Unit